home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / lsp / defmacro.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  9KB  |  244 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;    defmacro.lsp
  6. ;;;;
  7. ;;;;         defines SI:DEFMACRO*, the defmacro preprocessor
  8.  
  9.  
  10. (in-package 'lisp)
  11. (export '(&whole &environment &body))
  12.  
  13.  
  14. (in-package 'system)
  15.  
  16.  
  17. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  18.  
  19.  
  20. ;;; valid lambda-list to DEFMACRO is:
  21. ;;;
  22. ;;;    ( [ &whole sym ]
  23. ;;;      [ &environment sym ]
  24. ;;;      { v }*
  25. ;;;      [ &optional { sym | ( v [ init [ v ] ] ) }* ]
  26. ;;;      {  [ { &rest | &body } v ]
  27. ;;;         [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }*
  28. ;;;            [ &allow-other-keys ]]
  29. ;;;         [ &aux { sym | ( v [ init ] ) }* ]
  30. ;;;      |  . sym }
  31. ;;;     )
  32. ;;;
  33. ;;; where v is short for { defmacro-lambda-list | sym }.
  34. ;;; A symbol may be accepted as a DEFMACRO lambda-list, in which case
  35. ;;; (DEFMACRO <name> <symbol> ... ) is equivalent to
  36. ;;; (DEFMACRO <name> (&REST <symbol>) ...).
  37. ;;; Defamcro-lambda-list is defined as:
  38. ;;;
  39. ;;;    ( { v }*
  40. ;;;      [ &optional { sym | ( v [ init [ v ] ] ) }* ]
  41. ;;;      {  [ { &rest | &body } v ]
  42. ;;;         [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }*
  43. ;;;            [ &allow-other-keys ]]
  44. ;;;         [ &aux { sym | ( v [ init ] ) }* ]
  45. ;;;      |  . sym }
  46. ;;;     )
  47.  
  48. (defvar *dl*)
  49. (defvar *key-check*)
  50. (defvar *arg-check*)
  51.  
  52. (defun si:defmacro* (name vl body
  53.                           &aux *dl* (*key-check* nil)
  54.                                (*arg-check* nil)
  55.                                doc decls whole ppn (env nil) (envp nil))
  56.   (cond ((listp vl))
  57.         ((symbolp vl) (setq vl (list '&rest vl)))
  58.         (t (error "The defmacro-lambda-list ~s is not a list." vl)))
  59.   (multiple-value-setq (doc decls body) (find-doc body nil))
  60.   (cond ((and (listp vl) (eq (car vl) '&whole))
  61.          (setq whole (cadr vl)) (setq vl (cddr vl)))
  62.         (t (setq whole (gensym))))
  63.   (cond ((and (listp vl) (eq (car vl) '&environment))
  64.          (setq env (cadr vl))
  65.          (setq vl (cddr vl))
  66.          (setq envp t))
  67.         (t (setq env (gensym))))
  68.   (setq *dl* `(&aux ,env ,whole))
  69.   (setq ppn (dm-vl vl whole t))
  70.   (dolist (kc *key-check*)
  71.           (push `(unless (getf ,(car kc) :allow-other-keys)
  72.                          (do ((vl ,(car kc) (cddr vl)))
  73.                              ((endp vl))
  74.                              (unless (member (car vl) ',(cdr kc))
  75.                                      (dm-key-not-allowed (car vl))
  76.                                      )))
  77.                 body))
  78.   (dolist (ac *arg-check*)
  79.           (push `(unless (endp ,(dm-nth-cdr (cdr ac) (car ac)))
  80.                          (dm-too-many-arguments)) body))
  81.   (unless envp (push `(declare (ignore ,env)) body))
  82.   (list doc ppn `(lambda-block ,name ,(reverse *dl*) ,@(append decls body)))
  83.   )
  84.  
  85. (defun dm-vl (vl whole top)
  86.   (do ((optionalp nil) (restp nil) (keyp nil)
  87.        (allow-other-keys-p nil) (auxp nil)
  88.        (rest nil) (allow-other-keys nil) (keys nil) (no-check nil)
  89.        (n (if top 1 0)) (ppn nil)
  90.        )
  91.       ((not (consp vl))
  92.        (when vl
  93.          (when restp (dm-bad-key '&rest))
  94.          (push (list vl (dm-nth-cdr n whole)) *dl*)
  95.          (setq no-check t))
  96.        (when (and rest (not allow-other-keys))
  97.          (push (cons rest keys) *key-check*))
  98.        (unless no-check (push (cons whole n) *arg-check*))
  99.        ppn
  100.        )
  101.     (let ((v (car vl)))
  102.       (cond
  103.        ((eq v '&optional)
  104.         (when optionalp (dm-bad-key '&optional))
  105.         (setq optionalp t)
  106.         (pop vl))
  107.        ((or (eq v '&rest) (eq v '&body))
  108.         (when restp (dm-bad-key v))
  109.         (dm-v (cadr vl) (dm-nth-cdr n whole))
  110.         (setq restp t optionalp t no-check t)
  111.         (setq vl (cddr vl))
  112.         (when (eq v '&body) (setq ppn (if top (1- n) n))))
  113.        ((eq v '&key)
  114.         (when keyp (dm-bad-key '&key))
  115.         (setq rest (gensym))
  116.         (push (list rest (dm-nth-cdr n whole)) *dl*)
  117.         (setq keyp t restp t optionalp t no-check t)
  118.         (pop vl))
  119.        ((eq v '&allow-other-keys)
  120.         (when (or (not keyp) allow-other-keys-p)
  121.               (dm-bad-key '&allow-other-keys))
  122.         (setq allow-other-keys-p t)
  123.         (setq allow-other-keys t)
  124.         (pop vl))
  125.        ((eq v '&aux)
  126.         (when auxp (dm-bad-key '&aux))
  127.         (setq auxp t allow-other-keys-p t keyp t restp t optionalp t)
  128.         (pop vl))
  129.        (auxp
  130.         (let (x (init nil))
  131.              (cond ((symbolp v) (setq x v))
  132.                    (t (setq x (car v))
  133.                       (unless (endp (cdr v)) (setq init (cadr v)))))
  134.              (dm-v x init))
  135.         (pop vl))
  136.        (keyp
  137.         (let ((temp (gensym)) x k (init nil) (sv nil))
  138.              (cond ((symbolp v) (setq x v k (intern (string v) 'keyword)))
  139.                    (t (if (symbolp (car v))
  140.                           (setq x (car v)
  141.                                 k (intern (string (car v)) 'keyword))
  142.                           (setq x (cadar v) k (caar v)))
  143.                       (unless (endp (cdr v))
  144.                               (setq init (cadr v))
  145.                               (unless (endp (cddr v))
  146.                                       (setq sv (caddr v))))))
  147.              (dm-v temp `(getf ,rest ,k 'failed))
  148.              (dm-v x `(if (eq ,temp 'failed) ,init ,temp))
  149.              (when sv (dm-v sv `(not (eq ,temp 'failed))))
  150.              (push k keys))
  151.         (pop vl))
  152.        (optionalp
  153.         (let (x (init nil) (sv nil))
  154.              (cond ((symbolp v) (setq x v))
  155.                    (t (setq x (car v))
  156.                       (unless (endp (cdr v))
  157.                               (setq init (cadr v))
  158.                               (unless (endp (cddr v))
  159.                                       (setq sv (caddr v))))))
  160.              (dm-v x `(if ,(dm-nth-cdr n whole) ,(dm-nth n whole) ,init))
  161.              (when sv (dm-v sv `(not (null ,(dm-nth-cdr n whole))))))
  162.         (incf n)
  163.         (pop vl)
  164.         )
  165.        (t (dm-v v `(if ,(dm-nth-cdr n whole)
  166.                        ,(dm-nth n whole)
  167.                        (dm-too-few-arguments)))
  168.           (incf n)
  169.           (pop vl))
  170.        ))))
  171.  
  172. (defun dm-v (v init)
  173.        (if (symbolp v)
  174.            (push (if init (list v init) v) *dl*)
  175.            (let ((temp (gensym)))
  176.                 (push (if init (list temp init) temp) *dl*)
  177.                 (dm-vl v temp nil))))
  178.  
  179. (defun dm-nth (n v)
  180.   (multiple-value-bind (q r) (floor n 4)
  181.      (dotimes (i q) (setq v (list 'cddddr v)))
  182.      (case r
  183.         (0 (list 'car v))
  184.         (1 (list 'cadr v))
  185.         (2 (list 'caddr v))
  186.         (3 (list 'cadddr v))
  187.         )))
  188.  
  189. (defun dm-nth-cdr (n v)
  190.   (multiple-value-bind (q r) (floor n 4)
  191.      (dotimes (i q) (setq v (list 'cddddr v)))
  192.      (case r
  193.         (0 v)
  194.         (1 (list 'cdr v))
  195.         (2 (list 'cddr v))
  196.         (3 (list 'cdddr v))
  197.         )))
  198.  
  199. (defun dm-bad-key (key)
  200.        (error "Defmacro-lambda-list contains illegal use of ~s." key))
  201.  
  202. (defun dm-too-few-arguments ()
  203.        (error "Too few arguments are supplied to defmacro-lambda-list."))
  204.  
  205. (defun dm-too-many-arguments ()
  206.        (error "Too many arguments are supplied to defmacro-lambda-list."))
  207.  
  208. (defun dm-key-not-allowed (key)
  209.        (error "The key ~s is not allowed." key))
  210.  
  211. (defun find-doc (body ignore-doc)
  212.   (if (endp body)
  213.       (values nil nil nil)
  214.       (let ((d (macroexpand (car body))))
  215.         (cond ((stringp d)
  216.                (if (or (endp (cdr body)) ignore-doc)
  217.                    (values nil nil (cons d (cdr body)))
  218.                    (multiple-value-bind (doc decls b) (find-doc (cdr body) t)
  219.                      (declare (ignore doc))
  220.                      (values d decls b))))
  221.               ((and (consp d) (eq (car d) 'declare))
  222.                (multiple-value-bind (doc decls b)
  223.                                     (find-doc (cdr body) ignore-doc)
  224.                  (values doc (cons d decls) b)))
  225.               (t (values nil nil (cons d (cdr body))))))))
  226.  
  227. (defun find-declarations (body)
  228.   (if (endp body)
  229.       (values nil nil)
  230.       (let ((d (macroexpand (car body))))
  231.         (cond ((stringp d)
  232.                (if (endp (cdr body))
  233.                    (values nil (list d))
  234.                    (multiple-value-bind (ds b)
  235.                        (find-declarations (cdr body))
  236.                      (values (cons d ds) b))))
  237.               ((and (consp d) (eq (car d) 'declare))
  238.                (multiple-value-bind (ds b)
  239.                    (find-declarations (cdr body))
  240.                  (values (cons d ds) b)))
  241.               (t
  242.                (values nil (cons d (cdr body))))))))
  243.  
  244.